home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / sampledb.arj / SAMPDBQB.BAS < prev   
Encoding:
BASIC Source File  |  1993-08-06  |  13.2 KB  |  470 lines
  1. 'Written by Bill Slamer 
  2.  DECLARE SUB Loaddatafields ()
  3.  DECLARE SUB Printrecords ()
  4.  DECLARE SUB Showmenu ()
  5.  DECLARE SUB Loadeditfield ()
  6.  DECLARE SUB Updaterec ()
  7.  DECLARE SUB Editcustomer ()
  8.  DECLARE SUB Openfiles ()
  9.  DECLARE SUB Sortindex ()
  10.  DECLARE SUB Showcustomers ()
  11.  DECLARE SUB Deleterecord ()
  12.  DECLARE SUB Checkfordups ()
  13.  DEFINT A-Z
  14. '$INCLUDE: 'ArrowKey.Inc'
  15.  COLOR 15, 1: CLS
  16. DIM SHARED N$(500), N(500), Fielddesc$(10), Fieldlen(10), Deleted(50)
  17. DIM SHARED Editfield$(10), Menu$(10)
  18. DIM SHARED Mrow, Currec, Y$, Deleted
  19. DIM SHARED Maxrows, Row, Currtop, Extnd, Arraylocation
  20.  CLS
  21.  TYPE Customerrecord
  22.  Company   AS STRING * 30
  23.  Contact   AS STRING * 30
  24.  Address1  AS STRING * 30
  25.  Address2  AS STRING * 30
  26.  City      AS STRING * 15
  27.  State     AS STRING * 2
  28.  Zip       AS STRING * 10
  29.  Phone     AS STRING * 13
  30.  Fax       AS STRING * 13
  31.  Date      AS STRING * 10
  32.  END TYPE
  33.  DIM SHARED Custrec AS Customerrecord
  34. '*** load Menu Selections
  35. DATA View all customers, Edit a customer record
  36. DATA Add a customer record,Print all customer records,Quit
  37.  FOR X = 1 TO 5
  38.    READ Menu$(X)
  39.    Menu$(X) = LEFT$("     " + Menu$(X) + SPACE$(50), 50)
  40.  NEXT
  41. '*** load Array With Record Fields
  42.  FOR X = 1 TO 10: READ Fielddesc$(X), Fieldlen(X): NEXT
  43. DATA Company,30,Contact,30,Address1,30,Address2,30,City,15,State,2
  44. DATA Zip,10,Phone,14,Fax,14,Date,10
  45.  Openfiles  'open Any Files That Need To Be Opened
  46.  Sortindex  'sort Index
  47.  Showmenu  'display Menu
  48.  
  49. SUB Checkfordups
  50. SHARED Dup, N$(), Maxrows, Editfield$()
  51.  FOR X = 1 TO Maxrows
  52.    IF Editfield$(1) = N$(X) THEN
  53.      BEEP: Dup = 1
  54.      COLOR 15, 4: LOCATE 16, 16
  55.      PRINT "The field COMPANY is a DUPLICATE, press any key";
  56.      Z$ = INPUT$(1)
  57.      COLOR 15, 1: LOCATE 16, 16
  58.      PRINT SPACE$(55);
  59.      EXIT FOR
  60.    END IF
  61.  NEXT
  62. END SUB
  63.  
  64. SUB Deleterecord
  65. SHARED Maxrows, Currec, N(), N$(), Deleted(), Deleted, Editfield$(), D$
  66.  COLOR 15, 4
  67.  LOCATE 16, 14: PRINT "Are you sure you want to delete this record (Y or N)";
  68.  D$ = INPUT$(1): D$ = UCASE$(D$)
  69.  COLOR 15, 1
  70.  IF D$ = "N" THEN
  71.    LOCATE 16, 14: PRINT SPACE$(55);
  72.    EXIT SUB
  73.  END IF
  74.  FOR X = 1 TO Maxrows
  75.    IF N$(X) = Editfield$(1) THEN EXIT FOR
  76.  NEXT
  77.  FOR Y = X TO Maxrows
  78.    N$(Y) = N$(Y + 1)
  79.    N(Y) = N(Y + 1)
  80.  NEXT
  81.  Maxrows = Maxrows - 1
  82.  Loaddatafields
  83.  Custrec.Company = "DELETED"
  84.  PUT #1, Currec, Custrec
  85.  Deleted = Deleted + 1
  86.  Deleted(Deleted) = Currec
  87. END SUB
  88.  
  89. SUB Editcustomer
  90. SHARED Maxrows, Currec, N(), N$(), Deleted(), Deleted, D$, Dup
  91.  COLOR 15, 1: CLS
  92.  LOCATE 1, 60: PRINT "] Insert OFF ["
  93.  FOR X = 1 TO 10
  94.    COLOR 15, 1: LOCATE X + 4, 11: PRINT Fielddesc$(X)
  95.    IF Mrow = 3 THEN
  96.      Editfield$(X) = SPACE$(Fieldlen(X))
  97.    END IF
  98.    IF Mrow = 3 THEN Editfield$(10) = DATE$
  99.    COLOR , 0: LOCATE X + 4, 21: PRINT Editfield$(X)
  100.  NEXT
  101.  IF Mrow = 2 THEN
  102.    LOCATE 18, 13: PRINT CHR$(24) + CHR$(25) + " " + CHR$(26) + CHR$(27) + " <Alt U>pdate  <ESC> quit  <Ins>  <Alt D>elete"
  103.  ELSE
  104.    LOCATE 18, 20: PRINT CHR$(24) + CHR$(25) + " " + CHR$(26) + CHR$(27) + " <Alt S>ave  <ESC> quit  <Ins>"
  105.  END IF
  106.  
  107.  Row = 1: Col = 1: Nooffields = 10
  108.  DO
  109.    COLOR 0, 7: LOCATE Row + 4, Col + 20
  110.    PRINT MID$(Editfield$(Row), Col, 1)
  111.    X$ = "": WHILE X$ = "": X$ = INKEY$: WEND: X$ = UCASE$(X$)
  112.    COLOR 15, 0: LOCATE Row + 4, Col + 20
  113.    PRINT MID$(Editfield$(Row), Col, 1)
  114.    SELECT CASE X$
  115.      CASE CHR$(0) + CHR$(32)
  116.        Deleterecord
  117.        IF D$ = "Y" THEN
  118.          EXIT SUB
  119.        END IF
  120.      CASE ESC$
  121.        COLOR 15, 1: CLS
  122.        EXIT SUB
  123.      CASE CHR$(0) + CHR$(22)  'alt U (update Record)
  124. '*** everything Entered Is Stored In Editfield$() array.
  125.        IF Mrow = 2 THEN    'make Sure Programe Is In Edit Mode
  126.        COLOR 15, 1: CLS  'before Allowing Update.
  127.        Loaddatafields
  128.        Updaterec
  129.        EXIT SUB
  130.      END IF
  131.    CASE CHR$(0) + CHR$(31)  'alt S (save New Record)
  132. '*** everything Entered Is Stored In Editfield$() array.
  133.      IF Mrow = 3 THEN     'make Sure Program Is In Add Mode
  134.      Checkfordups
  135.      IF Dup = 0 THEN
  136.        COLOR 15, 1: CLS   'before Allowing Save.
  137.        Loaddatafields
  138.        Maxrows = Maxrows + 1
  139.        IF Deleted > 0 THEN
  140.          Currec = Deleted(Deleted)
  141.          Deleted = Deleted - 1
  142.          N(Maxrows) = Currec
  143.        ELSE
  144.          Currec = Maxrows + Deleted
  145.          N(Maxrows) = Maxrows
  146.        END IF
  147.        N$(Maxrows) = Custrec.Company
  148.        Updaterec
  149.        Sortindex
  150.        EXIT SUB
  151.      ELSE
  152.        Dup = 0
  153.      END IF
  154.    END IF
  155.  CASE UpArrow$
  156.    Col = 1: Row = Row - 1: IF Row < 1 THEN Row = Nooffields
  157.  CASE DnArrow$, Enter$
  158.    Col = 1: Row = Row + 1: IF Row > Nooffields THEN Row = 1
  159.  CASE LArrow$
  160.    Col = Col - 1: IF Col < 1 THEN Col = Fieldlen(Row)
  161.  CASE RArrow$
  162.    Col = Col + 1: IF Col > Fieldlen(Row) THEN Col = 1
  163.  CASE PgUp$
  164.    Col = 1: Row = 1
  165.  CASE PgDn$
  166.    Col = 1: Row = Nooffields
  167.  CASE Ins$
  168.    COLOR , 1
  169.    IF Inc = 1 THEN
  170.      Inc = 0: LOCATE 1, 60: PRINT "] Insert OFF ["
  171.    ELSE
  172.      Inc = 1: LOCATE 1, 60: PRINT "] Insert ON  ["
  173.    END IF
  174.    COLOR , 0
  175.  CASE Del$
  176.    F$ = MID$(Editfield$(Row), Col + 1, Fieldlen(Row))
  177.    F1$ = LEFT$(Editfield$(Row), Col - 1) + F$ + " "
  178.    Editfield$(Row) = F1$
  179.    LOCATE Row + 4, 21: PRINT Editfield$(Row)
  180.  CASE HomeK$
  181.    Col = 1: IF Row = 5 OR Row = 6 THEN Col = 2
  182.  CASE EndK$
  183.    Col = Fieldlen(Row)
  184.  CASE BS$
  185.    IF Col > 1 THEN
  186.      F$ = MID$(Editfield$(Row), Col, Fieldlen(Row))
  187.      F1$ = LEFT$(Editfield$(Row), Col - 2) + F$ + " "
  188.      Editfield$(Row) = F1$
  189.      Col = Col - 1: IF Col < 1 THEN Col = 1
  190.      LOCATE Row + 4, 21: PRINT Editfield$(Row)
  191.    END IF
  192.  CASE IS > CHR$(31), IS < CHR$(126)
  193.    IF Inc = 1 THEN
  194.      F$ = MID$(Editfield$(Row), Col, Fieldlen(Row))
  195.      F1$ = LEFT$(LEFT$(Editfield$(Row), Col - 1) + X$ + F$, Fieldlen(Row))
  196.      Editfield$(Row) = F1$
  197.      Col = Col + 1: IF Col > Fieldlen(Row) THEN Col = 1
  198.      LOCATE Row + 4, 21: PRINT Editfield$(Row)
  199.    ELSE
  200.      MID$(Editfield$(Row), Col) = X$
  201.      LOCATE Row + 4, 21: PRINT Editfield$(Row)
  202.      Col = Col + 1: IF Col > Fieldlen(Row) THEN Col = 1
  203.    END IF
  204.  END SELECT
  205.  LOOP
  206. END SUB
  207.  
  208. SUB Loaddatafields
  209. SHARED Editfield$()
  210.  Custrec.Company = Editfield$(1)
  211.  Custrec.Contact = Editfield$(2)
  212.  Custrec.Address1 = Editfield$(3)
  213.  Custrec.Address2 = Editfield$(4)
  214.  Custrec.City = Editfield$(5)
  215.  Custrec.State = Editfield$(6)
  216.  Custrec.Zip = Editfield$(7)
  217.  Custrec.Phone = Editfield$(8)
  218.  Custrec.Fax = Editfield$(9)
  219.  Custrec.Date = Editfield$(10)
  220. END SUB
  221.  
  222. SUB Loadeditfield
  223. SHARED Maxrows, Currec, N(), N$()
  224.  Currec = N(Row + Extnd)
  225.  Arraylocation = Row + Extnd
  226.  GET #1, Currec, Custrec
  227.  Editfield$(1) = Custrec.Company
  228.  Editfield$(2) = Custrec.Contact
  229.  Editfield$(3) = Custrec.Address1
  230.  Editfield$(4) = Custrec.Address2
  231.  Editfield$(5) = Custrec.City
  232.  Editfield$(6) = Custrec.State
  233.  Editfield$(7) = Custrec.Zip
  234.  Editfield$(8) = Custrec.Phone
  235.  Editfield$(9) = Custrec.Fax
  236.  Editfield$(10) = Custrec.Date
  237. END SUB
  238.  
  239. SUB Openfiles
  240. SHARED Maxrows, Currec, N(), N$(), Deleted(), Deleted
  241.  OPEN "test.txt" FOR RANDOM AS 1 LEN = LEN(Custrec)
  242.  FOR X = 1 TO LOF(1) / LEN(Custrec)
  243.    GET #1, X, Custrec
  244.    IF LEFT$(Custrec.Company, 7) = "DELETED" THEN
  245.      Deleted = Deleted + 1
  246.      Deleted(Deleted) = X
  247.    ELSE
  248.      Maxrows = Maxrows + 1
  249.      N$(Maxrows) = Custrec.Company
  250.      N(Maxrows) = X
  251.    END IF
  252.  NEXT
  253. END SUB
  254.  
  255. SUB Printrecords
  256. SHARED Maxrows, Currec, N(), N$()
  257.  COLOR 31, 1
  258.  LOCATE 12, 25: PRINT "Printing Records"
  259.  F$ = "\                          \  \                          \  \                            \  \                   \  \\ \            \"
  260.  LPRINT CHR$(15);
  261.  WIDTH "lpt1:", 132
  262.  FOR X = 1 TO LOF(1) / LEN(Custrec)
  263.    GET #1, X, Custrec
  264.    LPRINT USING F$; Custrec.Company; Custrec.Contact; Custrec.Address1; Custrec.City; Custrec.State; Custrec.Phone;
  265.  NEXT
  266.  COLOR 15, 1
  267. END SUB
  268.  
  269. SUB Showcustomers
  270. SHARED Maxrows, Currec, N(), N$()
  271.  COLOR 15, 1: CLS
  272.  COLOR 15, 2
  273.  LOCATE 4, 3: PRINT CHR$(201) + STRING$(72, CHR$(205)) + CHR$(187)
  274.  FOR X = 1 TO 8
  275.    LOCATE X + 4, 3: PRINT CHR$(186) + SPACE$(72) + CHR$(186)
  276.  NEXT
  277.  LOCATE 12, 3: PRINT CHR$(200) + STRING$(72, CHR$(205)) + CHR$(188)
  278.  LOCATE 6, 10: PRINT "The text in the box below will show the"
  279.  LOCATE 7, 10: PRINT "customers you have.  You can scroll through"
  280.  LOCATE 8, 10: PRINT "them by using the ARROW keys."
  281.  IF Mrow = 2 THEN
  282.    LOCATE 10, 10: PRINT "<RETURN> selects record for editing."
  283.  END IF
  284.  COLOR , 4
  285.  LOCATE 14, 3: PRINT CHR$(201) + STRING$(72, CHR$(205)) + CHR$(187)
  286.  FOR X = 1 TO 10
  287.    LOCATE X + 14, 3: PRINT CHR$(186) + SPACE$(72) + CHR$(186);
  288.  NEXT
  289.  LOCATE 24, 3: PRINT CHR$(200) + STRING$(72, CHR$(205)) + CHR$(188);
  290.  FOR X = 1 TO 9
  291.    COLOR 15, 4: LOCATE X + 14, 5: PRINT LEFT$(N$(X) + SPACE$(70), 70);
  292.  NEXT
  293.  COLOR 15, 3
  294.  LOCATE 24, 30: PRINT CHR$(24) + CHR$(25) + "      <RETURN> menu";
  295.  COLOR 15, 1
  296.  Row = 1: Extnd = 0: Currtop = 1
  297.  DO
  298.    COLOR 0, 7: LOCATE Row + 14, 5
  299.    PRINT LEFT$(N$(Row + Extnd) + SPACE$(70), 70);
  300.    Y$ = "": WHILE Y$ = "": Y$ = INKEY$: WEND: Y$ = UCASE$(Y$)
  301.    COLOR 15, 4: LOCATE Row + 14, 5
  302.    PRINT LEFT$(N$(Row + Extnd) + SPACE$(70), 70);
  303.    SELECT CASE Y$
  304.      CASE ESC$
  305.        COLOR 15, 1
  306.        CLS
  307.        EXIT SUB
  308.      CASE Enter$
  309.        COLOR 15, 1
  310.        IF Mrow = 2 THEN Loadeditfield
  311.        CLS : EXIT SUB
  312.      CASE PgUp$
  313.        FOR Y = 1 TO 8
  314.          IF Row - 1 >= 1 THEN
  315.            Row = Row - 1
  316.          ELSE
  317.            IF Row = 1 AND Extnd > 0 THEN
  318.              Currtop = Currtop - 1
  319.              Extnd = Extnd - 1
  320.              GOSUB SCROLLONELINEDOWN
  321.            END IF
  322.          END IF
  323.        NEXT
  324.      CASE UpArrow$
  325.        IF Row - 1 >= 1 THEN
  326.          Row = Row - 1
  327.        ELSE
  328.          IF Row = 1 AND Extnd > 0 THEN
  329.            Currtop = Currtop - 1
  330.            Extnd = Extnd - 1
  331.            GOSUB SCROLLONELINEDOWN
  332.          END IF
  333.        END IF
  334.      CASE PgDn$
  335.        FOR Y = 1 TO 8
  336.          IF Row + 1 + Extnd <= Maxrows THEN
  337.            Row = Row + 1
  338.            IF Row > 9 THEN
  339.              Currtop = Currtop + 1
  340.              Row = 9: Extnd = Extnd + 1
  341.              GOSUB SCROLLONELINEUP
  342.            END IF
  343.          END IF
  344.        NEXT
  345.      CASE DnArrow$
  346.        IF Row + 1 + Extnd <= Maxrows THEN
  347.          Row = Row + 1
  348.          IF Row > 9 THEN
  349.            Currtop = Currtop + 1
  350.            Row = 9: Extnd = Extnd + 1
  351.            GOSUB SCROLLONELINEUP
  352.          END IF
  353.        END IF
  354.    END SELECT
  355.  LOOP
  356.  EXIT SUB
  357. SCROLLONELINEUP:
  358.  Srow = 15
  359.  FOR X = Currtop TO Currtop + 7
  360.    LOCATE Srow, 5: PRINT LEFT$(N$(X) + SPACE$(70), 70)
  361.    Srow = Srow + 1
  362.  NEXT
  363.  RETURN
  364. SCROLLONELINEDOWN:
  365.  Srow = 22
  366.  FOR X = Currtop + 7 TO Currtop STEP -1
  367.    LOCATE Srow, 5: PRINT LEFT$(N$(X) + SPACE$(70), 70);
  368.    Srow = Srow - 1
  369.  NEXT
  370.  RETURN
  371. END SUB
  372.  
  373. SUB Showmenu
  374. '*** make Menu Box
  375. MAKEMENU:
  376.  DO
  377.    CLS
  378.    COLOR 15, 4
  379.    LOCATE 4, 15: PRINT CHR$(201) + STRING$(50, CHR$(205)) + CHR$(187)
  380.    LOCATE 4, 30: PRINT "[ Ziggy's Main Menu ]"
  381.    FOR X = 1 TO 8
  382.      LOCATE X + 4, 15: PRINT CHR$(186) + SPACE$(50) + CHR$(186)
  383.    NEXT
  384.  
  385. '*** print Menu Selections
  386.    LOCATE 12, 15: PRINT CHR$(200) + STRING$(50, CHR$(205)) + CHR$(188)
  387.    FOR X = 1 TO 5: LOCATE X + 5, 16: PRINT Menu$(X): NEXT
  388.  
  389.    Mrow = 1: Noofselections = 5
  390.    DO
  391.      COLOR 0, 7: LOCATE Mrow + 5, 16: PRINT Menu$(Mrow)
  392.      X$ = "": WHILE X$ = "": X$ = INKEY$: WEND: X$ = UCASE$(X$)
  393.      COLOR 15, 4: LOCATE Mrow + 5, 16: PRINT Menu$(Mrow)
  394.      SELECT CASE X$
  395.        CASE ESC$
  396.          COLOR 7, 0
  397.          CLS : END
  398.        CASE Enter$
  399.          SELECT CASE Mrow
  400.            CASE 1  'view All Customers
  401.              CLS
  402.              Showcustomers
  403.              EXIT DO
  404.            CASE 2  'edit A Customer Record
  405.              CLS
  406.              Showcustomers
  407.              IF Y$ <> ESC$ THEN
  408.                Editcustomer
  409.              END IF
  410.              EXIT DO
  411.            CASE 3  'add A Customer Record
  412.              CLS
  413.              Editcustomer
  414.              EXIT DO
  415.            CASE 4  'print All Customer Records
  416.              CLS
  417.              Printrecords
  418.              EXIT DO
  419.            CASE 5  'quit
  420.              COLOR 7, 0
  421.              CLOSE : CLS : END
  422.          END SELECT
  423.        CASE UpArrow$
  424.          Mrow = Mrow - 1
  425.          IF Mrow < 1 THEN Mrow = Noofselections
  426.        CASE DnArrow$
  427.          Mrow = Mrow + 1
  428.          IF Mrow > Noofselections THEN Mrow = 1
  429.      END SELECT
  430.    LOOP
  431.  LOOP
  432. END SUB
  433.  
  434. SUB Sortindex
  435. SHARED Maxrows, Currec, N(), N$()
  436.  IF Maxrows < 1 THEN EXIT SUB
  437.  Maxarray% = Maxrows
  438.  REDIM Stackl%(Maxarray%), Stackr%(Maxarray%)
  439.  Sx% = 1: Stackl%(1) = 1: Stackr%(1) = Maxarray%
  440.  WHILE Sx% <> 0
  441.    Lx% = Stackl%(Sx%): Rx% = Stackr%(Sx%): Sx% = Sx% - 1
  442.    WHILE Lx% < Rx%
  443.      Ix% = Lx%: Jx% = Rx%: X$ = N$((Lx% + Rx%) \ 2)
  444.      WHILE Ix% <= Jx%
  445.        WHILE N$(Ix%) < X$: Ix% = Ix% + 1: WEND
  446.        WHILE N$(Jx%) > X$: Jx% = Jx% - 1: WEND
  447.        X0% = 0
  448.        WHILE (Ix% <= Jx% AND X0% = 0)
  449.          X0% = 1: SWAP N$(Ix%), N$(Jx%)
  450.          SWAP N(Ix%), N(Jx%)
  451.          Ix% = Ix% + 1: Jx% = Jx% - 1
  452.        WEND
  453.      WEND
  454.      X0% = 0
  455.      WHILE (Ix% <= Rx% AND X0% = 0)
  456.        X0% = 1: Sx% = Sx% + 1
  457.        Stackl%(Sx%) = Ix%: Stackr%(Sx%) = Rx%
  458.      WEND
  459.      Rx% = Jx%
  460.    WEND
  461.  WEND
  462.  ERASE Stackl%, Stackr%
  463. END SUB
  464.  
  465. SUB Updaterec
  466. SHARED Maxrows, Currec, N(), N$()
  467.  PUT #1, Currec, Custrec
  468. END SUB
  469.  
  470.